home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Interp⁄Comp (.scm) / pvm.scm < prev    next >
Encoding:
Text File  |  1992-06-14  |  61.1 KB  |  1,646 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "pvm.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Virtual machine abstraction package:
  8. ; -----------------------------------
  9.  
  10. ; (See file 'doc/pvm' for details on the virtual machine)
  11.  
  12. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  13. ;
  14. ; Virtual machine operands:
  15. ; ------------------------
  16. ;
  17. ; Operands are represented with small integers.  Operands can thus be tested
  18. ; for equality using 'eqv?'.  'eqv-opnd?' also tests for equal operands but
  19. ; it disregards the '?' flag.  The encoding is as follows:
  20. ;
  21. ; OPERAND      ENCODING         
  22. ;
  23. ; reg(n)       0     + n
  24. ; stk(n)       10000 + n
  25. ; lbl(n)       20000 + n
  26. ; glo(name)    30000 + index in operand table
  27. ; clo(opnd,n)  40000 + index in operand table
  28. ; obj(x)       50000 + index in operand table
  29. ; ?loc         60000 + encoding(loc)
  30.  
  31. ; Utilities:
  32. ; ---------
  33.  
  34. (define *opnd-table* '())
  35. (define *opnd-table-alloc* '())
  36.  
  37. (define opnd-table-size 10000)
  38.  
  39. (define (enter-opnd arg1 arg2)
  40.   (let loop ((i 0))
  41.     (if (< i *opnd-table-alloc*)
  42.       (let ((x (vector-ref *opnd-table* i)))
  43.         (if (and (eqv? (car x) arg1) (eqv? (cdr x) arg2))
  44.           i
  45.           (loop (+ i 1))))
  46.       (if (< *opnd-table-alloc* opnd-table-size)
  47.         (begin
  48.           (set! *opnd-table-alloc* (+ *opnd-table-alloc* 1))
  49.           (vector-set! *opnd-table* i (cons arg1 arg2))
  50.           i)
  51.         (compiler-limitation-error
  52.           "program is too long [virtual machine operand table overflow]")))))
  53.  
  54. (define (eqv-opnd? opnd1 opnd2)
  55.   (eqv? (strip-pot-fut opnd1) (strip-pot-fut opnd2)))
  56.  
  57. (define (contains-opnd? opnd1 opnd2) ; does opnd2 contain opnd1?
  58.   (cond ((eqv-opnd? opnd1 opnd2)
  59.          #t)
  60.         ((clo? opnd2)
  61.          (contains-opnd? opnd1 (clo-base opnd2)))
  62.         (else
  63.          #f)))
  64.  
  65. (define (any-contains-opnd? opnd opnds)
  66.   (if (null? opnds)
  67.     #f
  68.     (or (contains-opnd? opnd (car opnds))
  69.         (any-contains-opnd? opnd (cdr opnds)))))
  70.  
  71. ; Locations:
  72. ; ---------
  73.  
  74. ; -- location is a register (first is number 0)
  75. (define (make-reg num) num)
  76. (define (reg? x) (< (modulo x 60000) 10000))
  77. (define (reg-num x) (modulo x 10000))
  78.  
  79. ; -- location is in the stack (first slot in procedure's frame is number 1)
  80. (define (make-stk num) (+ num 10000))
  81. (define (stk? x) (= (quotient (modulo x 60000) 10000) 1))
  82. (define (stk-num x) (modulo x 10000))
  83.  
  84. ; -- location is a global variable
  85. (define (make-glo name) (+ (enter-opnd name #t) 30000))
  86. (define (glo? x) (= (quotient (modulo x 60000) 10000) 3))
  87. (define (glo-name x) (car (vector-ref *opnd-table* (modulo x 10000))))
  88.  
  89. ; -- location is a closed variable (base is ptr to closure env, index >= 1)
  90. (define (make-clo base index) (+ (enter-opnd base index) 40000))
  91. (define (clo? x) (= (quotient (modulo x 60000) 10000) 4))
  92. (define (clo-base x) (car (vector-ref *opnd-table* (modulo x 10000))))
  93. (define (clo-index x) (cdr (vector-ref *opnd-table* (modulo x 10000))))
  94.  
  95. ; Values:
  96. ; ------
  97.  
  98. ; -- value is the address of a local label
  99. (define (make-lbl num) (+ num 20000))
  100. (define (lbl? x) (= (quotient (modulo x 60000) 10000) 2))
  101. (define (lbl-num x) (modulo x 10000))
  102. (define label-limit 9999) ; largest label
  103.  
  104. ; -- value is a scheme object
  105. (define (make-obj val) (+ (enter-opnd val #f) 50000))                    
  106. (define (obj? x) (= (quotient (modulo x 60000) 10000) 5))         
  107. (define (obj-val x) (car (vector-ref *opnd-table* (modulo x 10000))))
  108.  
  109. ; Potentially future flag: (operands that should be touched to get their value)
  110. ; -----------------------
  111.  
  112. (define (put-pot-fut loc) (+ loc 60000))
  113. (define (pot-fut? x) (>= x 60000))
  114. (define (strip-pot-fut x) (modulo x 60000))
  115. (define (set-pot-fut loc flag) (if flag (put-pot-fut loc) loc))
  116.  
  117. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  118. ;
  119. ; Processor context descriptions:
  120. ; ------------------------------
  121.  
  122. (define (make-pcontext fs map)
  123.   (vector fs map))
  124.  
  125. (define (pcontext-fs  x) (vector-ref x 0))
  126. (define (pcontext-map x) (vector-ref x 1))
  127.  
  128. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  129. ;
  130. ; Frame description:
  131. ; -----------------
  132.  
  133. (define (make-frame size slots regs closed live)
  134.   (vector size slots regs closed live))
  135.  
  136. (define (frame-size x)   (vector-ref x 0))
  137. (define (frame-slots x)  (vector-ref x 1))
  138. (define (frame-regs x)   (vector-ref x 2))
  139. (define (frame-closed x) (vector-ref x 3))
  140. (define (frame-live x)   (vector-ref x 4))
  141.  
  142. (define (frame-eq? x y)
  143.   (= (frame-size x) (frame-size y)))
  144.  
  145. (define (frame-truncate frame nb-slots)
  146.   (let ((fs (frame-size frame)))
  147.     (make-frame nb-slots
  148.                 (nth-after (frame-slots frame) (- fs nb-slots))
  149.                 (frame-regs frame)
  150.                 (frame-closed frame)
  151.                 (frame-live frame))))
  152.  
  153. (define (frame-live? var frame)
  154.   (let ((live (frame-live frame)))
  155.     (if (eq? var closure-env-var)
  156.       (let ((closed (frame-closed frame)))
  157.         (if (or (set-member? var live)
  158.                 (not (set-empty? (set-intersection live (list->set closed)))))
  159.           closed
  160.           #f))
  161.       (if (set-member? var live)
  162.         var
  163.         #f))))
  164.  
  165. (define (frame-first-empty-slot frame)
  166.   (let loop ((i 1) (s (reverse (frame-slots frame))))
  167.     (if (pair? s)
  168.       (if (frame-live? (car s) frame)
  169.         (loop (+ i 1) (cdr s))
  170.         i)
  171.       i)))
  172.  
  173. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  174. ;
  175. ; Procedure objects:
  176. ; -----------------
  177.  
  178. (define (make-proc-obj
  179.           name
  180.           primitive?
  181.           code
  182.           call-pat
  183.           side-effects?
  184.           strict-pat
  185.           type)
  186.   (let ((proc-obj
  187.           (vector
  188.             proc-obj-tag
  189.             name
  190.             primitive?
  191.             code
  192.             call-pat
  193.             #f ; test
  194.             #f ; inlinable
  195.             #f ; specialize
  196.             side-effects?
  197.             strict-pat
  198.             type)))
  199.     (proc-obj-specialize-set! proc-obj (lambda (decls) proc-obj))
  200.     proc-obj))
  201.  
  202. (define proc-obj-tag (list 'PROC-OBJ))
  203.  
  204. (define (proc-obj? x)
  205.   (and (vector? x)
  206.        (> (vector-length x) 0)
  207.        (eq? (vector-ref x 0) proc-obj-tag)))
  208.  
  209. (define (proc-obj-name obj)                (vector-ref obj 1))
  210. (define (proc-obj-primitive? obj)          (vector-ref obj 2))
  211. (define (proc-obj-code obj)                (vector-ref obj 3))
  212. (define (proc-obj-call-pat obj)            (vector-ref obj 4))
  213. (define (proc-obj-test obj)                (vector-ref obj 5))
  214. (define (proc-obj-inlinable obj)           (vector-ref obj 6))
  215. (define (proc-obj-specialize obj)          (vector-ref obj 7))
  216. (define (proc-obj-side-effects? obj)       (vector-ref obj 8))
  217. (define (proc-obj-strict-pat obj)          (vector-ref obj 9))
  218. (define (proc-obj-type obj)                (vector-ref obj 10))
  219.  
  220. (define (proc-obj-code-set! obj x)         (vector-set! obj 3 x))
  221. (define (proc-obj-test-set! obj x)         (vector-set! obj 5 x))
  222. (define (proc-obj-inlinable-set! obj x)    (vector-set! obj 6 x))
  223. (define (proc-obj-specialize-set! obj x)   (vector-set! obj 7 x))
  224.  
  225. (define (make-pattern min-args nb-parms rest?)
  226.   (let loop ((x (if rest? (- nb-parms 1) (list nb-parms)))
  227.              (y (if rest? (- nb-parms 1) nb-parms)))
  228.     (let ((z (- y 1)))
  229.       (if (< z min-args) x (loop (cons z x) z)))))
  230.  
  231. (define (pattern-member? n pat) ; tests if 'n' is a member of pattern 'pat'
  232.   (cond ((pair? pat)
  233.          (if (= (car pat) n) #t (pattern-member? n (cdr pat))))
  234.         ((null? pat)
  235.          #f)
  236.         (else
  237.          (<= pat n))))
  238.  
  239. (define (type-name type)
  240.   (if (pair? type) (car type) type))
  241.  
  242. (define (type-pot-fut? type)
  243.   (pair? type))
  244.  
  245. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  246. ;
  247. ; Basic block set manipulation:
  248. ; ----------------------------
  249.  
  250. ; Virtual instructions have a linear structure.  However, this is not how
  251. ; they are put together to form a piece of code.  Rather, virtual instructions
  252. ; are grouped into 'basic blocks' which are 'linked' together.  A basic block
  253. ; is a LABEL instruction followed by a sequence of non-branching instructions
  254. ; (i.e. APPLY, COPY or MAKE_CLOSURES) terminated by a single branch
  255. ; instruction (i.e. COND or JUMP).  Links between basic
  256. ; blocks are denoted using label references.  When a basic block ends with a
  257. ; COND instruction, the block is linked to the two basic blocks corresponding
  258. ; to the two possible control paths out of the COND instruction.  When a basic
  259. ; block ends with a JUMP instruction, there is either zero or one link.
  260. ;
  261. ; Basic blocks naturally group together to form 'basic block sets'.  A basic
  262. ; block set describes all the code of a procedure.
  263.  
  264. (define (make-bbs)
  265.  
  266.   (define (limit-error)
  267.     (compiler-limitation-error "procedure is too long [too many labels]"))
  268.  
  269.   (vector (make-counter label-limit limit-error) ; 0 - local label counter
  270.           (queue-empty)                          ; 1 - basic block queue
  271.           '()))                                  ; 2 - entry label number
  272.  
  273. (define (bbs-lbl-counter bbs)                (vector-ref bbs 0))
  274. (define (bbs-bb-queue bbs)                   (vector-ref bbs 1))
  275. (define (bbs-bb-queue-set! bbs bbq)          (vector-set! bbs 1 bbq))
  276. (define (bbs-entry-lbl-num bbs)              (vector-ref bbs 2))
  277. (define (bbs-entry-lbl-num-set! bbs lbl-num) (vector-set! bbs 2 lbl-num))
  278.  
  279. (define (bbs-new-lbl! bbs)
  280.   ((bbs-lbl-counter bbs)))
  281.  
  282. (define (lbl-num->bb lbl-num bbs)
  283.   (let loop ((bb-list (queue->list (bbs-bb-queue bbs))))
  284.     (if (= (bb-lbl-num (car bb-list)) lbl-num)
  285.       (car bb-list)
  286.       (loop (cdr bb-list)))))
  287.  
  288. ; Basic block manipulation procedures:
  289.  
  290. (define (make-bb label-instr bbs)
  291.   (let ((bb (vector
  292.               label-instr   ; 0 - LABEL instr
  293.               (queue-empty) ; 1 - sequence of non-branching instrs
  294.               '()           ; 2 - branch instruction
  295.               '()           ; 3 - basic blocks referenced by this block
  296.               '())))        ; 4 - basic blocks which jump to this block
  297.                             ;     (both filled in by 'bbs-purify!')
  298.     (queue-put! (vector-ref bbs 1) bb)
  299.     bb))
  300.  
  301. (define (bb-lbl-num bb)                  (LABEL-lbl-num (vector-ref bb 0)))
  302. (define (bb-label-type bb)               (LABEL-type (vector-ref bb 0)))
  303. (define (bb-label-instr bb)              (vector-ref bb 0))
  304. (define (bb-label-instr-set! bb l)       (vector-set! bb 0 l))
  305. (define (bb-non-branch-instrs bb)        (queue->list (vector-ref bb 1)))
  306. (define (bb-non-branch-instrs-set! bb l) (vector-set! bb 1 (list->queue l)))
  307. (define (bb-branch-instr bb)             (vector-ref bb 2))
  308. (define (bb-branch-instr-set! bb b)      (vector-set! bb 2 b))
  309. (define (bb-references bb)               (vector-ref bb 3))
  310. (define (bb-references-set! bb l)        (vector-set! bb 3 l))
  311. (define (bb-precedents bb)               (vector-ref bb 4))
  312. (define (bb-precedents-set! bb l)        (vector-set! bb 4 l))
  313.  
  314. (define (bb-entry-frame-size bb)
  315.   (frame-size (pvm-instr-frame (bb-label-instr bb))))
  316.  
  317. (define (bb-exit-frame-size bb)
  318.   (frame-size (pvm-instr-frame (bb-branch-instr bb))))
  319.  
  320. (define (bb-slots-gained bb)
  321.   (- (bb-exit-frame-size bb) (bb-entry-frame-size bb)))
  322.  
  323. (define (bb-put-non-branch! bb pvm-instr)
  324.   (queue-put! (vector-ref bb 1) pvm-instr))
  325.  
  326. (define (bb-put-branch! bb pvm-instr)
  327.   (vector-set! bb 2 pvm-instr))
  328.  
  329. (define (bb-add-reference! bb ref)
  330.   (if (not (memq ref (vector-ref bb 3)))
  331.     (vector-set! bb 3 (cons ref (vector-ref bb 3)))))
  332.  
  333. (define (bb-add-precedent! bb prec)
  334.   (if (not (memq prec (vector-ref bb 4)))
  335.     (vector-set! bb 4 (cons prec (vector-ref bb 4)))))
  336.  
  337. ; Virtual machine instruction representation:
  338.  
  339. (define (pvm-instr-type pvm-instr)    (vector-ref pvm-instr 0))
  340. (define (pvm-instr-frame pvm-instr)   (vector-ref pvm-instr 1))
  341. (define (pvm-instr-comment pvm-instr) (vector-ref pvm-instr 2))
  342.  
  343. (define (make-LABEL-SIMP lbl-num frame comment)
  344.   (vector 'LABEL frame comment lbl-num 'SIMP))
  345.  
  346. (define (make-LABEL-TASK lbl-num method frame comment)
  347.   (vector 'LABEL frame comment lbl-num 'TASK method))
  348.  
  349. (define (make-LABEL-PROC lbl-num nb-parms min rest? closed? frame comment)
  350.   (vector 'LABEL frame comment lbl-num 'PROC nb-parms min rest? closed?))
  351.  
  352. (define (make-LABEL-RETURN lbl-num task-method frame comment)
  353.   (vector 'LABEL frame comment lbl-num 'RETURN task-method))
  354.  
  355. (define (LABEL-lbl-num pvm-instr)            (vector-ref pvm-instr 3))
  356. (define (LABEL-type pvm-instr)               (vector-ref pvm-instr 4))
  357.  
  358. (define (LABEL-TASK-method pvm-instr)        (vector-ref pvm-instr 5))
  359.  
  360. (define (LABEL-PROC-nb-parms pvm-instr)      (vector-ref pvm-instr 5))
  361. (define (LABEL-PROC-min pvm-instr)           (vector-ref pvm-instr 6))
  362. (define (LABEL-PROC-rest? pvm-instr)         (vector-ref pvm-instr 7))
  363. (define (LABEL-PROC-b-branch-instr bb))))
  364.             (if jump-lbl-num
  365.               (jump-cascade-to
  366.                 jump-lbl-num
  367.                 (+ fs (bb-slots-gained bb))
  368.                 (or intr-check? (JUMP-intr-check? (bb-branch-instr bb)))
  369.                 (cons lbl-num seen)
  370.                 thunk)
  371.               (thunk lbl-num fs intr-check?)))
  372.           (thunk lbl-num fs intr-check?)))))
  373.  
  374.   (define (equiv-lbl lbl-num seen)
  375.     (if (memq lbl-num seen) ; infinite loop?
  376.       lbl-num
  377.       (let ((bb (lbl-num->bb lbl-num bbs)))
  378.         (if (empty-bb? bb)
  379.           (let ((jump-lbl-num
  380.                  (jump-to-non-entry-lbl? (bb-branch-instr bb))))
  381.             (if (and jump-lbl-num
  382.                      (not (JUMP-intr-check? (bb-branch-instr bb)))
  383.                      (= (bb-slots-gained bb) 0))
  384.               (equiv-lbl jump-lbl-num (cons lbl-num seen))
  385.               lbl-num))
  386.           lbl-num))))
  387.  
  388.   (define (remove-cascade! bb)
  389.     (let ((branch (bb-branch-instr bb)))
  390.  
  391.       (case (pvm-instr-type branch)
  392.  
  393.         ((COND)
  394.          (bb-put-branch! bb  ; branch is a COND
  395.            (make-COND (COND-test branch)
  396.                       (COND-opnds branch)
  397.                       (equiv-lbl (COND-true branch) '())
  398.                       (equiv-lbl (COND-false branch) '())
  399.                       (COND-intr-check? branch)
  400.                       (pvm-instr-frame branch)
  401.                       (pvm-instr-comment branch))))
  402.  
  403.         ((JUMP)  ; branch is a JUMP
  404.          (if (not (first-class-JUMP? branch)) ; but not to an entry label
  405.            (let ((dest-lbl-num (jump-lbl? branch)))
  406.              (if dest-lbl-num
  407.  
  408.                (jump-cascade-to
  409.                  dest-lbl-num
  410.                  (frame-size (pvm-instr-frame branch))
  411.                  (JUMP-intr-check? branch)
  412.                  '()
  413.                  (lambda (lbl-num fs intr-check?)
  414.                    (let* ((dest-bb (lbl-num->bb lbl-num bbs))
  415.                           (last-branch (bb-branch-instr dest-bb)))
  416.                      (if (and (empty-bb? dest-bb)
  417.                               (or (not intr-check?)
  418.                                   put-intr-check-on-COND?
  419.                                   (not (eq? (pvm-instr-type last-branch) 'COND))))
  420.  
  421.                        (let* ((new-fs (+ fs (bb-slots-gained dest-bb)))
  422.                               (new-frame (frame-truncate
  423.                                            (pvm-instr-frame branch)
  424.                                            new-fs)))
  425.  
  426.                          (define (adjust-opnd opnd)
  427.                            (cond ((stk? opnd)
  428.                                   (set-pot-fut
  429.                                     (make-stk
  430.                                       (+ (- fs (bb-entry-frame-size dest-bb))
  431.                                          (stk-num opnd)))
  432.                                     (pot-fut? opnd)))
  433.                                  ((clo? opnd)
  434.                                   (set-pot-fut
  435.                                     (make-clo (adjust-opnd (clo-base opnd))
  436.                                               (clo-index opnd))
  437.                                     (pot-fut? opnd)))
  438.                                  (else
  439.                                   opnd)))
  440.  
  441.                          (case (pvm-instr-type last-branch)
  442.                            ((COND)
  443.                             (bb-put-branch! bb
  444.                               (make-COND (COND-test last-branch)
  445.                                          (map adjust-opnd (COND-opnds last-branch))
  446.                                          (equiv-lbl (COND-true last-branch) '())
  447.                                          (equiv-lbl (COND-false last-branch) '())
  448.                                          (or intr-check?
  449.                                              (COND-intr-check? last-branch))
  450.                                          new-frame
  451.                                          (pvm-instr-comment last-branch))))
  452.                            ((JUMP)
  453.                             (bb-put-branch! bb
  454.                               (make-JUMP (adjust-opnd (JUMP-opnd last-branch))
  455.                                          (JUMP-nb-args last-branch)
  456.                                          (or intr-check?
  457.                                              (JUMP-intr-check? last-branch))
  458.                                          new-frame
  459.                                          (pvm-instr-comment last-branch))))
  460.                            (else
  461.                             (compiler-internal-error
  462.                               "bbs-remove-jump-cascades!, unknown branch type"))))
  463.  
  464.                        (bb-put-branch! bb
  465.                          (make-JUMP (make-lbl lbl-num)
  466.                                     (JUMP-nb-args branch)
  467.                                     (or intr-check?
  468.                                         (JUMP-intr-check? branch))
  469.                                     (frame-truncate
  470.                                       (pvm-instr-frame branch)
  471.                                       fs)
  472.                                     (pvm-instr-comment branch)))))))))))
  473.  
  474.         (else
  475.          (compiler-internal-error
  476.            "bbs-remove-jump-cascades!, unknown branch type")))))
  477.  
  478.   (for-each remove-cascade!
  479.             (queue->list (bbs-bb-queue bbs))))
  480.  
  481. (define put-intr-check-on-COND? #f)
  482. (set! put-intr-check-on-COND? #t)
  483.  
  484. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  485.  
  486. ; Step 2, Dead code removal:
  487.  
  488. (define (bbs-remove-dead-code! bbs)
  489.  
  490.   (let ((new-bb-queue (queue-empty))
  491.         (scan-queue (queue-empty)))
  492.  
  493.     (define (reachable ref bb)
  494.       (if bb (bb-add-reference! bb ref))
  495.       (if (not (memq ref (queue->list new-bb-queue)))
  496.         (begin
  497.           (bb-references-set! ref '())
  498.           (bb-precedents-set! ref '())
  499.           (queue-put! new-bb-queue ref)
  500.           (queue-put! scan-queue ref))))
  501.  
  502.     (define (direct-jump to-bb from-bb)
  503.       (reachable to-bb from-bb)
  504.       (bb-add-precedent! to-bb from-bb))
  505.  
  506.     (define (scan-instr pvm-instr bb)
  507.  
  508.       (define (scan-opnd pvm-opnd)
  509.         (cond ((lbl? pvm-opnd)
  510.                (reachable (lbl-num->bb (lbl-num pvm-opnd) bbs) bb))
  511.               ((clo? pvm-opnd)
  512.                (scan-opnd (clo-base pvm-opnd)))))
  513.  
  514.       (case (pvm-instr-type pvm-instr)
  515.  
  516.         ((LABEL)
  517.          '())
  518.  
  519.         ((APPLY)
  520.          (for-each scan-opnd (APPLY-opnds pvm-instr))
  521.          (if (APPLY-loc pvm-instr)
  522.            (scan-opnd (APPLY-loc pvm-instr))))
  523.  
  524.         ((COPY)
  525.          (scan-opnd (COPY-opnd pvm-instr))
  526.          (scan-opnd (COPY-loc pvm-instr)))
  527.  
  528.         ((MAKE_CLOSURES)
  529.          (for-each (lambda (parm)
  530.                      (reachable (lbl-num->bb (closure-parms-lbl parm) bbs) bb)
  531.                      (scan-opnd (closure-parms-loc parm))
  532.                      (for-each scan-opnd (closure-parms-opnds parm)))
  533.                    (MAKE_CLOSURES-parms pvm-instr)))
  534.  
  535.         ((COND)
  536.          (for-each scan-opnd (COND-opnds pvm-instr))
  537.          (direct-jump (lbl-num->bb (COND-true pvm-instr) bbs) bb)
  538.          (direct-jump (lbl-num->bb (COND-false pvm-instr) bbs) bb))
  539.  
  540.         ((JUMP)
  541.          (let ((opnd (JUMP-opnd pvm-instr)))
  542.            (if (lbl? opnd)
  543.              (direct-jump (lbl-num->bb (lbl-num opnd) bbs) bb)
  544.              (scan-opnd (JUMP-opnd pvm-instr)))))
  545.  
  546.         (else
  547.          (compiler-internal-error
  548.            "bbs-remove-dead-code!, unknown PVM instruction type"))))
  549.  
  550.     (reachable (lbl-num->bb (bbs-entry-lbl-num bbs) bbs) #f)
  551.  
  552.     (let loop ()
  553.       (if (not (queue-empty? scan-queue))
  554.         (let ((bb (queue-get! scan-queue)))
  555.           (begin
  556.             (scan-instr (bb-label-instr bb) bb)
  557.             (for-each (lambda (pvm-instr) (scan-instr pvm-instr bb))
  558.                       (bb-non-branch-instrs bb))
  559.             (scan-instr (bb-branch-instr bb) bb)
  560.             (loop)))))
  561.  
  562.     (bbs-bb-queue-set! bbs new-bb-queue)))
  563.  
  564. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  565.  
  566. ; Step 3, Common code removal:
  567.  
  568. (define (bbs-remove-common-code! bbs)
  569.   (let* ((bb-list (queue->list (bbs-bb-queue bbs)))
  570.          (n (length bb-list))
  571.          (hash-table-length
  572.            (cond ((< n 50)  43) ; select reasonable size for hash table
  573.                  ((< n 500) 403)
  574.                  (else      4003)))
  575.          (hash-table (make-vector hash-table-length '()))
  576.          (prim-table '())
  577.          (block-map '())
  578.          (changed? #f))
  579.  
  580.   (define (hash-prim prim)
  581.     (let ((n (length prim-table))
  582.           (i (pos-in-list prim prim-table)))
  583.       (if i
  584.         (- n i)
  585.         (begin
  586.           (set! prim-table (cons prim prim-table))
  587.           (+ n 1)))))
  588.  
  589.   (define (hash-opnds l) ; this assumes that operands are encoded with nbs
  590.     (let loop ((l l) (n 0))
  591.       (if (pair? l)
  592.         (loop (cdr l)
  593.               (let ((x (car l)))
  594.                 (if (lbl? x) n (modulo (+ (* n 10000) x) hash-table-length))))
  595.         n)))
  596.  
  597.   (define (hash-bb bb) ; compute hash address for a basic block
  598.     (let ((branch (bb-branch-instr bb)))
  599.       (modulo
  600.         (case (pvm-instr-type branch)
  601.           ((COND)
  602.            (+ (hash-opnds (COND-opnds branch))
  603.               (* 10 (hash-prim (COND-test branch)))
  604.               (* 100 (frame-size (pvm-instr-frame branch)))))
  605.           ((JUMP)
  606.            (+ (hash-opnds (list (JUMP-opnd branch)))
  607.               (* 10 (or (JUMP-nb-args branch) -1))
  608.               (* 100 (frame-size (pvm-instr-frame branch)))))
  609.           (else
  610.            0))
  611.         hash-table-length)))
  612.  
  613.   (define (replacement-lbl-num lbl)
  614.     (let ((x (assv lbl block-map)))
  615.       (if x (cdr x) lbl)))
  616.  
  617.   (define (fix-map! bb1 bb2) ; bb1 should be replaced by bb2 in the block-map
  618.     (let loop ((l block-map))
  619.       (if (pair? l)
  620.         (let ((x (car l)))
  621.           (if (= bb1 (cdr x)) (set-cdr! x bb2))
  622.           (loop (cdr l))))))
  623.  
  624.   (define (enter-bb! bb) ; enter a basic block in the hash table
  625.     (let ((h (hash-bb bb)))
  626.       (vector-set! hash-table h
  627.         (add-bb bb (vector-ref hash-table h)))))
  628.  
  629.   (define (add-bb bb l) ; add basic block 'bb' to list of basic blocks
  630.     (if (pair? l)
  631.       (let ((bb* (car l))) ; pick next basic block in list
  632.  
  633.         (set! block-map ; for now, assume that 'bb' = 'bb*'
  634.           (cons (cons (bb-lbl-num bb) (bb-lbl-num bb*))
  635.                 block-map))
  636.  
  637.         (if (eqv-bb? bb bb*) ; are they the same?
  638.  
  639.           (begin
  640.             (fix-map! (bb-lbl-num bb) (bb-lbl-num bb*)) ; record the equivalence
  641.             (set! changed? #t)
  642.             l)
  643.  
  644.           (begin
  645.             (set! block-map (cdr block-map)) ; they are not the same!
  646.             (if (eqv-pvm-instr? (bb-branch-instr bb) (bb-branch-instr bb*))
  647.  
  648.               (extract-common-tail bb bb* ; check if tail is the same
  649.                 (lambda (head head* tail)
  650.                   (if (null? tail) ; common tail long enough?
  651.  
  652.                     (cons bb* (add-bb bb (cdr l))) ; no, so try rest of list
  653.  
  654.                     (let* ((lbl (bbs-new-lbl! bbs)) ; create bb for common tail
  655.                            (branch (bb-branch-instr bb))
  656.                            (fs** (need-pvm-instrs tail branch))
  657.                            (frame (frame-truncate
  658.                                     (pvm-instr-frame
  659.                                       (if (null? head)
  660.                                         (bb-label-instr bb)
  661.                                         (car head)))
  662.                                     fs**))
  663.                            (bb** (make-bb (make-LABEL-SIMP lbl frame #f) bbs)))
  664.                       (bb-non-branch-instrs-set! bb** tail)
  665.                       (bb-branch-instr-set! bb** branch)
  666.                       (bb-non-branch-instrs-set! bb* (reverse head*))
  667.                       (bb-branch-instr-set! bb*
  668.                         (make-JUMP (make-lbl lbl) #f #f frame #f))
  669.                       (bb-non-branch-instrs-set! bb (reverse head))
  670.                       (bb-branch-instr-set! bb
  671.                         (make-JUMP (make-lbl lbl) #f #f frame #f))
  672.                       (set! changed? #t)
  673.                       (cons bb (cons bb* (add-bb bb** (cdr l))))))))
  674.  
  675.                 (cons bb* (add-bb bb (cdr l)))))))
  676.  
  677.         (list bb)))
  678.  
  679.   (define (extract-common-tail bb1 bb2 cont)
  680.     (let loop ((l1 (reverse (bb-non-branch-instrs bb1)))
  681.                (l2 (reverse (bb-non-branch-instrs bb2)))
  682.                (tail '()))
  683.       (if (and (pair? l1) (pair? l2))
  684.         (let ((i1 (car l1))
  685.               (i2 (car l2)))
  686.           (if (eqv-pvm-instr? i1 i2)
  687.             (loop (cdr l1) (cdr l2) (cons i1 tail))
  688.             (cont l1 l2 tail)))
  689.         (cont l1 l2 tail))))
  690.  
  691.   (define (eqv-bb? bb1 bb2)
  692.     (let ((bb1-non-branch (bb-non-branch-instrs bb1))
  693.           (bb2-non-branch (bb-non-branch-instrs bb2)))
  694.       (and (= (length bb1-non-branch) (length bb2-non-branch))
  695.            (eqv-pvm-instr? (bb-label-instr bb1) (bb-label-instr bb2))
  696.            (eqv-pvm-instr? (bb-branch-instr bb1) (bb-branch-instr bb2))
  697.            (eqv-list? eqv-pvm-instr? bb1-non-branch bb2-non-branch))))
  698.  
  699.   (define (eqv-list? pred? l1 l2)
  700.     (if (pair? l1)
  701.       (and (pair? l2)
  702.            (pred? (car l1) (car l2))
  703.            (eqv-list? pred? (cdr l1) (cdr l2)))
  704.       (not (pair? l2))))
  705.  
  706.   (define (eqv-lbl-num? lbl1 lbl2)
  707.     (= (replacement-lbl-num lbl1)
  708.        (replacement-lbl-num lbl2)))
  709.  
  710.   (define (eqv-pvm-opnd? opnd1 opnd2)
  711.     (if (not opnd1)
  712.       (not opnd2)
  713.       (and opnd2
  714.            (eq? (pot-fut? opnd1) (pot-fut? opnd2))
  715.            (cond ((lbl? opnd1)
  716.                   (and (lbl? opnd2)
  717.                        (eqv-lbl-num? (lbl-num opnd1) (lbl-num opnd2))))
  718.                  ((clo? opnd1)
  719.                   (and (clo? opnd2)
  720.                        (= (clo-index opnd1) (clo-index opnd2))
  721.                        (eqv-pvm-opnd? (clo-base opnd1)
  722.                                       (clo-base opnd2))))
  723.                  (else
  724.                   (eqv? opnd1 opnd2))))))
  725.     
  726.   (define (eqv-pvm-instr? instr1 instr2)
  727.  
  728.     (define (eqv-closure-parms? p1 p2)
  729.       (and (eqv-pvm-opnd? (closure-parms-loc p1)
  730.                           (closure-parms-loc p2))
  731.            (eqv-lbl-num? (closure-parms-lbl p1)
  732.                          (closure-parms-lbl p2))
  733.            (eqv-list? eqv-pvm-opnd?
  734.                       (closure-parms-opnds p1)
  735.                       (closure-parms-opnds p2))))
  736.  
  737.     (let ((type1 (pvm-instr-type instr1))
  738.           (type2 (pvm-instr-type instr2)))
  739.       (and (eq? type1 type2)
  740.            (frame-eq? (pvm-instr-frame instr1) (pvm-instr-frame instr2))
  741.            (case type1
  742.  
  743.              ((LABEL)
  744.               (let ((ltype1 (LABEL-type instr1))
  745.                     (ltype2 (LABEL-type instr2)))
  746.                 (and (eq? ltype1 ltype2)
  747.                      (case ltype1
  748.                        ((SIMP)
  749.                         #t)
  750.                        ((TASK)
  751.                         (eq? (LABEL-TASK-method instr1)
  752.                              (LABEL-TASK-method instr2)))
  753.                        ((RETURN)
  754.                         (eq? (LABEL-RETURN-task-method instr1)
  755.                              (LABEL-RETURN-task-method instr2)))
  756.                        ((PROC)
  757.                         (and (= (LABEL-PROC-min instr1)
  758.                                 (LABEL-PROC-min instr2))
  759.                              (= (LABEL-PROC-nb-parms instr1)
  760.                                 (LABEL-PROC-nb-parms instr2))
  761.                              (eq? (LABEL-PROC-rest? instr1)
  762.                                   (LABEL-PROC-rest? instr2))
  763.                              (eq? (LABEL-PROC-closed? instr1)
  764.                                   (LABEL-PROC-closed? instr2))))
  765.                        (else
  766.                         (compiler-internal-error
  767.                           "eqv-pvm-instr?, unknown label type"))))))
  768.  
  769.              ((APPLY)
  770.               (and (eq? (APPLY-prim instr1) (APPLY-prim instr2))
  771.                    (eqv-list? eqv-pvm-opnd?
  772.                               (APPLY-opnds instr1)
  773.                               (APPLY-opnds instr2))
  774.                    (eqv-pvm-opnd? (APPLY-loc instr1)
  775.                                   (APPLY-loc instr2))))
  776.  
  777.              ((COPY)
  778.               (and (eqv-pvm-opnd? (COPY-opnd instr1)
  779.                                   (COPY-opnd instr2))
  780.                    (eqv-pvm-opnd? (COPY-loc instr1)
  781.                                   (COPY-loc instr2))))
  782.  
  783.              ((MAKE_CLOSURES)
  784.               (eqv-list? eqv-closure-parms?
  785.                          (MAKE_CLOSURES-parms instr1)
  786.                          (MAKE_CLOSURES-parms instr2)))
  787.  
  788.              ((COND)
  789.               (and (eq? (COND-test instr1)
  790.                         (COND-test instr2))
  791.                    (eqv-list? eqv-pvm-opnd?
  792.                               (COND-opnds instr1)
  793.                               (COND-opnds instr2))
  794.                    (eqv-lbl-num? (COND-true instr1)
  795.                                  (COND-true instr2))
  796.                    (eqv-lbl-num? (COND-false instr1)
  797.                                  (COND-false instr2))
  798.                    (eq? (COND-intr-check? instr1)
  799.                         (COND-intr-check? instr2))))
  800.  
  801.              ((JUMP)
  802.               (and (eqv-pvm-opnd? (JUMP-opnd instr1)
  803.                                   (JUMP-opnd instr2))
  804.                    (eqv? (JUMP-nb-args instr1)
  805.                          (JUMP-nb-args instr2))
  806.                    (eq? (JUMP-intr-check? instr1)
  807.                         (JUMP-intr-check? instr2))))
  808.  
  809.              (else
  810.               (compiler-internal-error
  811.                 "eqv-pvm-instr?, unknown 'pvm-instr':" instr1))))))
  812.  
  813.   (define (update-pvm-opnd opnd)
  814.     (if opnd
  815.       (cond ((lbl? opnd)
  816.              (set-pot-fut
  817.                (make-lbl (replacement-lbl-num (lbl-num opnd)))
  818.                (pot-fut? opnd)))
  819.             ((clo? opnd)
  820.              (set-pot-fut
  821.                (make-clo (update-pvm-opnd (clo-base opnd)) (clo-index opnd))
  822.                (pot-fut? opnd)))
  823.             (else
  824.              opnd))
  825.       opnd))
  826.  
  827.   (define (update-pvm-instr instr)
  828.  
  829.     (define (update-closure-parms p)
  830.       (make-closure-parms
  831.         (update-pvm-opnd (closure-parms-loc p))
  832.         (replacement-lbl-num (closure-parms-lbl p))
  833.         (map update-pvm-opnd (closure-parms-opnds p))))
  834.  
  835.     (case (pvm-instr-type instr)
  836.  
  837.       ((LABEL)
  838.        (case (LABEL-type instr)
  839.          ((SIMP)
  840.           (make-LABEL-SIMP (LABEL-lbl-num instr)
  841.                            (pvm-instr-frame instr)
  842.                            (pvm-instr-comment instr)))
  843.          ((TASK)
  844.           (make-LABEL-TASK (LABEL-lbl-num instr)
  845.                            (LABEL-TASK-method instr)
  846.                            (pvm-instr-frame instr)
  847.                            (pvm-instr-comment instr)))
  848.          ((PROC)
  849.           (make-LABEL-PROC (LABEL-lbl-num instr)
  850.                            (LABEL-PROC-nb-parms instr)
  851.                            (LABEL-PROC-min instr)
  852.                            (LABEL-PROC-rest? instr)
  853.                            (LABEL-PROC-closed? instr)
  854.                            (pvm-instr-frame instr)
  855.                            (pvm-instr-comment instr)))
  856.          ((RETURN)
  857.           (make-LABEL-RETURN (LABEL-lbl-num instr)
  858.                              (LABEL-RETURN-task-method instr)
  859.                              (pvm-instr-frame instr)
  860.                              (pvm-instr-comment instr)))
  861.          (else
  862.           (compiler-internal-error
  863.             "update-pvm-instr, unknown label type"))))
  864.  
  865.       ((APPLY)
  866.        (make-APPLY (APPLY-prim instr)
  867.                    (map update-pvm-opnd (APPLY-opnds instr))
  868.                    (update-pvm-opnd (APPLY-loc instr))
  869.                    (pvm-instr-frame instr)
  870.                    (pvm-instr-comment instr)))
  871.  
  872.       ((COPY)
  873.        (make-COPY (update-pvm-opnd (COPY-opnd instr))
  874.                   (update-pvm-opnd (COPY-loc instr))
  875.                   (pvm-instr-frame instr)
  876.                   (pvm-instr-comment instr)))
  877.  
  878.       ((MAKE_CLOSURES)
  879.        (make-MAKE_CLOSURES
  880.          (map update-closure-parms (MAKE_CLOSURES-parms instr))
  881.          (pvm-instr-frame instr)
  882.          (pvm-instr-comment instr)))
  883.  
  884.       ((COND)
  885.        (make-COND (COND-test instr)
  886.                   (map update-pvm-opnd (COND-opnds instr))
  887.                   (replacement-lbl-num (COND-true instr))
  888.                   (replacement-lbl-num (COND-false instr))
  889.                   (COND-intr-check? instr)
  890.                   (pvm-instr-frame instr)
  891.                   (pvm-instr-comment instr)))
  892.  
  893.       ((JUMP)
  894.        (make-JUMP (update-pvm-opnd (JUMP-opnd instr))
  895.                   (JUMP-nb-args instr)
  896.                   (JUMP-intr-check? instr)
  897.                   (pvm-instr-frame instr)
  898.                   (pvm-instr-comment instr)))
  899.  
  900.       (else
  901.        (compiler-internal-error
  902.          "update-pvm-instr, unknown 'instr':" instr))))
  903.  
  904.   (define (update-bb! bb)
  905.     (bb-label-instr-set! bb
  906.       (update-pvm-instr (bb-label-instr bb)))
  907.     (bb-non-branch-instrs-set! bb
  908.       (map update-pvm-instr (bb-non-branch-instrs bb)))
  909.     (bb-branch-instr-set! bb
  910.       (update-pvm-instr (bb-branch-instr bb))))
  911.  
  912.   ; Fill hash table, remove equivalent basic blocks and common tails
  913.  
  914.   (for-each enter-bb! bb-list)
  915.  
  916.   ; Reconstruct bbs
  917.  
  918.   (bbs-entry-lbl-num-set! bbs
  919.     (replacement-lbl-num (bbs-entry-lbl-num bbs)))
  920.  
  921.   (let loop ((i 0) (result '()))
  922.     (if (< i hash-table-length)
  923.       (let ((bb-kept (vector-ref hash-table i)))
  924.         (for-each update-bb! bb-kept)
  925.         (loop (+ i 1) (append bb-kept result)))
  926.       (bbs-bb-queue-set! bbs (list->queue result))))
  927.  
  928.   changed?))
  929.  
  930. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  931.  
  932. ; Step 4, Basic block set ordering:
  933.  
  934. (define (bbs-order! bbs)
  935.  
  936.   (let ((new-bb-queue (queue-empty))
  937.         (left-to-schedule (queue->list (bbs-bb-queue bbs))))
  938.  
  939.     (define (remove x l)
  940.       (if (eq? (car l) x)
  941.         (cdr l)
  942.         (cons (car l) (remove x (cdr l)))))
  943.  
  944.     ; update list of basic blocks not yet scheduled
  945.  
  946.     (define (remove-bb! bb)
  947.       (set! left-to-schedule (remove bb left-to-schedule))
  948.       bb)
  949.  
  950.     ; return a basic block which ends with a branch to 'bb' (and that is
  951.     ; still in 'left-to-schedule') or #f if there aren't any
  952.  
  953.     (define (prec-bb bb)
  954.       (let loop ((l (bb-precedents bb)) (best #f) (best-fs #f))
  955.         (if (null? l)
  956.           best
  957.           (let* ((x (car l))
  958.                  (x-fs (bb-exit-frame-size x)))
  959.             (if (and (memq x left-to-schedule)
  960.                      (or (not best) (< x-fs best-fs)))
  961.               (loop (cdr l) x x-fs)
  962.               (loop (cdr l) best best-fs))))))
  963.  
  964.     ; return the basic block which 'bb' jumps to (and that is still in
  965.     ; 'left-to-schedule') or #f if there aren't any
  966.  
  967.     (define (succ-bb bb)
  968.  
  969.       (define (branches-to-lbl? bb)
  970.         (let ((branch (bb-branch-instr bb)))
  971.           (case (pvm-instr-type branch)
  972.             ((COND) #t)
  973.             ((JUMP) (lbl? (JUMP-opnd branch)))
  974.             (else
  975.              (compiler-internal-error
  976.               "bbs-order!, unknown branch type")))))
  977.  
  978.       (define (best-succ bb1 bb2)   ; heuristic that determines which
  979.         (if (branches-to-lbl? bb1)  ; bb is most frequently executed
  980.            bb1
  981.            (if (branches-to-lbl? bb2)
  982.              bb2
  983.              (if (< (bb-exit-frame-size bb1)
  984.                     (bb-exit-frame-size bb2))
  985.                bb2
  986.                bb1))))
  987.  
  988.       (let ((branch (bb-branch-instr bb)))
  989.         (case (pvm-instr-type branch)
  990.           ((COND)
  991.            (let* ((true-bb (lbl-num->bb (COND-true branch) bbs))
  992.                   (true-bb* (and (memq true-bb left-to-schedule)
  993.                                  true-bb))
  994.                   (false-bb (lbl-num->bb (COND-false branch) bbs))
  995.                   (false-bb* (and (memq false-bb left-to-schedule)
  996.                                   false-bb)))
  997.              (if (and true-bb* false-bb*)
  998.                (best-succ true-bb* false-bb*)
  999.                (or true-bb* false-bb*))))
  1000.           ((JUMP)
  1001.            (let ((opnd (JUMP-opnd branch)))
  1002.              (and (lbl? opnd)
  1003.                   (let ((bb (lbl-num->bb (lbl-num opnd) bbs)))
  1004.                     (and (memq bb left-to-schedule) bb)))))
  1005.           (else
  1006.            (compiler-internal-error
  1007.              "bbs-order!, unknown branch type")))))
  1008.  
  1009.     ; schedule a given basic block 'bb' with it's predecessors and
  1010.     ; successors.
  1011.  
  1012.     (define (schedule-from bb)
  1013.       (queue-put! new-bb-queue bb)
  1014.       (let ((x (succ-bb bb)))
  1015.         (if x
  1016.           (begin
  1017.             (schedule-around (remove-bb! x))
  1018.             (let ((y (succ-bb bb)))
  1019.               (if y
  1020.                 (schedule-around (remove-bb! y)))))))
  1021.       (schedule-refs bb))
  1022.  
  1023.     (define (schedule-around bb)
  1024.       (let ((x (prec-bb bb)))
  1025.         (if x
  1026.           (let ((bb-list (schedule-back (remove-bb! x) '())))
  1027.             (queue-put! new-bb-queue x)
  1028.             (schedule-forw bb)
  1029.             (for-each schedule-refs bb-list))
  1030.           (schedule-from bb))))
  1031.  
  1032.     (define (schedule-back bb bb-list)
  1033.       (let ((bb-list* (cons bb bb-list))
  1034.             (x (prec-bb bb)))
  1035.         (if x
  1036.           (let ((bb-list (schedule-back (remove-bb! x) bb-list*)))
  1037.             (queue-put! new-bb-queue x)
  1038.             bb-list)
  1039.           bb-list*)))
  1040.  
  1041.     (define (schedule-forw bb)
  1042.       (queue-put! new-bb-queue bb)
  1043.       (let ((x (succ-bb bb)))
  1044.         (if x
  1045.           (begin
  1046.             (schedule-forw (remove-bb! x))
  1047.             (let ((y (succ-bb bb)))
  1048.               (if y
  1049.                 (schedule-around (remove-bb! y)))))))
  1050.       (schedule-refs bb))
  1051.  
  1052.     (define (schedule-refs bb)
  1053.       (for-each
  1054.         (lambda (x)
  1055.           (if (memq x left-to-schedule) (schedule-around (remove-bb! x))))
  1056.         (bb-references bb)))
  1057.  
  1058.     (schedule-from (remove-bb! (lbl-num->bb (bbs-entry-lbl-num bbs) bbs)))
  1059.  
  1060.     (bbs-bb-queue-set! bbs new-bb-queue)))
  1061.  
  1062. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1063. ;
  1064. ; Sequentialization of a basic block set:
  1065. ; --------------------------------------
  1066.  
  1067. ; The procedure 'bbs->code-list' transforms a 'purified' basic block set
  1068. ; into a sequence of virtual machine instructions.  Each element of the
  1069. ; resulting list is a 'code' object that contains a PVM instruction,
  1070. ; a pointer to the basic block it came from and a `slots needed' index
  1071. ; that specifies the minimum number of slots that have to be kept (relative
  1072. ; to the start of the frame) after the instruction is executed.
  1073. ; The procedure does a few optimizations: fall-through JUMP removal and
  1074. ; deletion of unnecessary LABELs.  The first element of the code list is the
  1075. ; entry label for the piece of code.
  1076.  
  1077. (define (make-code bb pvm-instr sn)     (vector bb pvm-instr sn))
  1078. (define (code-bb code)                  (vector-ref code 0))
  1079. (define (code-pvm-instr code)           (vector-ref code 1))
  1080. (define (code-slots-needed code)        (vector-ref code 2))
  1081. (define (code-slots-needed-set! code n) (vector-set! code 2 n))
  1082.  
  1083. (define (bbs->code-list bbs)
  1084.   (let ((code-list (linearize bbs)))
  1085.     (setup-slots-needed! code-list)
  1086.     code-list))
  1087.  
  1088. (define (linearize bbs) ; turn bbs into list and remove LABELs & JUMPs
  1089.  
  1090.   (let ((code-queue (queue-empty)))
  1091.  
  1092.     (define (put-bb prec-bb pres-bb next-bb label-needed?)
  1093.  
  1094.       (define (put-instr pvm-instr)
  1095.         (queue-put! code-queue (make-code pres-bb pvm-instr #f)))
  1096.  
  1097.       (if label-needed?
  1098.         (put-instr (bb-label-instr pres-bb))) ; put label only if truly needed
  1099.  
  1100.       (for-each put-instr (bb-non-branch-instrs pres-bb)) ; put non-branching instrs
  1101.  
  1102.       (let ((branch (bb-branch-instr pres-bb)))
  1103.         (case (pvm-instr-type branch)
  1104.           ((COND)
  1105.            (put-instr branch)
  1106.            #t)
  1107.  
  1108.           ((JUMP)
  1109.            (let ((opnd (JUMP-opnd branch)))
  1110.              (if (or (not next-bb) ; remove JUMP if it falls through?
  1111.                      (not (lbl? opnd))
  1112.                      (not (= (lbl-num opnd) (bb-lbl-num next-bb)))
  1113.                      (not (= (length (bb-precedents next-bb)) 1))
  1114.                      (not (eq? (bb-label-type next-bb) 'SIMP)) ; not a simple label
  1115.                      (not (= (frame-size (pvm-instr-frame branch))
  1116.                              (bb-entry-frame-size next-bb)))
  1117.                      (JUMP-intr-check? branch))
  1118.                (begin (put-instr branch) #t)
  1119.                #f)))
  1120.  
  1121.           (else
  1122.            (compiler-internal-error
  1123.              "linearize, unknown branch type")))))
  1124.  
  1125.     (let loop ((l (queue->list (bbs-bb-queue bbs)))
  1126.                (prev-bb #f)
  1127.                (label-needed? #t))
  1128.       (if (not (null? l))
  1129.         (let ((pres-bb (car l)))
  1130.           (loop (cdr l)
  1131.                 pres-bb
  1132.                 (put-bb prev-bb
  1133.                         pres-bb
  1134.                         (if (null? (cdr l)) #f (cadr l))
  1135.                         label-needed?)))))
  1136.  
  1137.     (queue->list code-queue)))
  1138.  
  1139. (define (setup-slots-needed! code-list) ; setup `slots-needed' field
  1140.   (if (null? code-list)
  1141.     #f
  1142.     (let* ((code (car code-list))
  1143.            (pvm-instr (code-pvm-instr code))
  1144.            (sn-rest (setup-slots-needed! (cdr code-list))))
  1145.  
  1146.       (case (pvm-instr-type pvm-instr)
  1147.  
  1148.         ((LABEL)
  1149.          (if (> sn-rest (frame-size (pvm-instr-frame pvm-instr)))
  1150.            (compiler-internal-error
  1151.              "setup-slots-needed!, incoherent slots needed for LABEL"))
  1152.          (code-slots-needed-set! code sn-rest)
  1153.          #f)
  1154.  
  1155.         ((COND JUMP)
  1156.          (let ((sn (frame-size (pvm-instr-frame pvm-instr))))
  1157.            (code-slots-needed-set! code sn)
  1158.            (need-pvm-instr pvm-instr sn)))
  1159.      
  1160.         (else 
  1161.          (code-slots-needed-set! code sn-rest)
  1162.          (need-pvm-instr pvm-instr sn-rest))))))
  1163.  
  1164. (define (need-pvm-instrs non-branch branch)
  1165.   (if (pair? non-branch)
  1166.     (need-pvm-instr (car non-branch)
  1167.                     (need-pvm-instrs (cdr non-branch) branch))
  1168.     (need-pvm-instr branch (frame-size (pvm-instr-frame branch)))))
  1169.  
  1170. (define (need-pvm-instr pvm-instr sn-rest)
  1171.   (case (pvm-instr-type pvm-instr)
  1172.  
  1173.     ((LABEL)
  1174.      sn-rest)
  1175.  
  1176.     ((APPLY)
  1177.      (let ((loc (APPLY-loc pvm-instr)))
  1178.        (need-pvm-opnds (APPLY-opnds pvm-instr)
  1179.          (need-pvm-loc-opnd loc
  1180.            (need-pvm-loc loc sn-rest)))))
  1181.  
  1182.     ((COPY)
  1183.      (let ((loc (COPY-loc pvm-instr)))
  1184.        (need-pvm-opnd (COPY-opnd pvm-instr)
  1185.          (need-pvm-loc-opnd loc
  1186.            (need-pvm-loc loc sn-rest)))))
  1187.  
  1188.     ((MAKE_CLOSURES)
  1189.      (let ((parms (MAKE_CLOSURES-parms pvm-instr)))
  1190.  
  1191.        (define (need-parms-opnds p)
  1192.          (if (null? p)
  1193.            sn-rest
  1194.            (need-pvm-opnds (closure-parms-opnds (car p))
  1195.              (need-parms-opnds (cdr p)))))
  1196.  
  1197.        (define (need-parms-loc p)
  1198.          (if (null? p)
  1199.            (need-parms-opnds parms)
  1200.            (let ((loc (closure-parms-loc (car p))))
  1201.              (need-pvm-loc-opnd loc
  1202.                (need-pvm-loc loc (need-parms-loc (cdr p)))))))
  1203.  
  1204.        (need-parms-loc parms)))
  1205.  
  1206.     ((COND)
  1207.      (need-pvm-opnds (COND-opnds pvm-instr) sn-rest))
  1208.  
  1209.     ((JUMP)
  1210.      (need-pvm-opnd (JUMP-opnd pvm-instr) sn-rest))
  1211.      
  1212.     (else 
  1213.      (compiler-internal-error
  1214.        "need-pvm-instr, unknown 'pvm-instr':" pvm-instr))))
  1215.  
  1216. (define (need-pvm-loc loc sn-rest)
  1217.   (if (and loc (stk? loc) (>= (stk-num loc) sn-rest))
  1218.     (- (stk-num loc) 1)
  1219.     sn-rest))
  1220.  
  1221. (define (need-pvm-loc-opnd pvm-loc slots-needed)
  1222.   (if (and pvm-loc (clo? pvm-loc))
  1223.     (need-pvm-opnd (clo-base pvm-loc) slots-needed)
  1224.     slots-needed))
  1225.  
  1226. (define (need-pvm-opnd pvm-opnd slots-needed)
  1227.   (cond ((stk? pvm-opnd)
  1228.          (max (stk-num pvm-opnd) slots-needed))
  1229.         ((clo? pvm-opnd)
  1230.          (need-pvm-opnd (clo-base pvm-opnd) slots-needed))
  1231.         (else
  1232.          slots-needed)))
  1233.  
  1234. (define (need-pvm-opnds pvm-opnds slots-needed)
  1235.   (if (null? pvm-opnds)
  1236.     slots-needed
  1237.     (need-pvm-opnd (car pvm-opnds)
  1238.                    (need-pvm-opnds (cdr pvm-opnds) slots-needed))))
  1239.  
  1240. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1241. ;
  1242. ; Basic block writing:
  1243. ; -------------------
  1244.  
  1245. (define (write-bb bb port)
  1246.   (write-pvm-instr (bb-label-instr bb) port)
  1247.   (display " [precedents=" port)
  1248.   (write (map bb-lbl-num (bb-precedents bb)) port)
  1249.   (display "]" port)
  1250.   (newline port)
  1251.  
  1252.   (for-each (lambda (x) (write-pvm-instr x port) (newline port))
  1253.             (bb-non-branch-instrs bb))
  1254.  
  1255.   (write-pvm-instr (bb-branch-instr bb) port))
  1256.  
  1257. (define (write-bbs bbs port)
  1258.   (for-each (lambda (bb)
  1259.               (if (= (bb-lbl-num bb) (bbs-entry-lbl-num bbs))
  1260.                 (begin (display "**** Entry block:" port) (newline port)))
  1261.               (write-bb bb port)
  1262.               (newline port))
  1263.             (queue->list (bbs-bb-queue bbs))))
  1264.  
  1265. (define (virtual.dump proc port)
  1266.  
  1267.   (let ((proc-seen (queue-empty))
  1268.         (proc-left (queue-empty)))
  1269.  
  1270.     (define (scan-opnd pvm-opnd)
  1271.       (cond ((obj? pvm-opnd)
  1272.              (let ((val (obj-val pvm-opnd)))
  1273.                (if (and (proc-obj? val)
  1274.                         (proc-obj-code val)
  1275.                         (not (memq val (queue->list proc-seen))))
  1276.                  (begin
  1277.                    (queue-put! proc-seen val)
  1278.                    (queue-put! proc-left val)))))
  1279.             ((clo? pvm-opnd)
  1280.              (scan-opnd (clo-base pvm-opnd)))))
  1281.  
  1282.     (define (dump-proc p)
  1283.  
  1284.       (define (scan-code code)
  1285.         (let ((pvm-instr (code-pvm-instr code))
  1286.               (slots-needed (code-slots-needed code)))
  1287.           (if (> slots-needed 9) (display "[" port) (display "[ " port))
  1288.           (display slots-needed port)
  1289.           (display "] " port)
  1290.  
  1291.           (write-pvm-instr pvm-instr port)
  1292.           (newline port)
  1293.           (case (pvm-instr-type pvm-instr)
  1294.  
  1295.             ((APPLY)
  1296.              (for-each scan-opnd (APPLY-opnds pvm-instr))
  1297.              (if (APPLY-loc pvm-instr)
  1298.                (scan-opnd (APPLY-loc pvm-instr))))
  1299.  
  1300.             ((COPY)
  1301.              (scan-opnd (COPY-opnd pvm-instr))
  1302.              (scan-opnd (COPY-loc pvm-instr)))
  1303.  
  1304.             ((MAKE_CLOSURES)
  1305.              (for-each (lambda (parms)
  1306.                          (scan-opnd (closure-parms-loc parms))
  1307.                          (for-each scan-opnd (closure-parms-opnds parms)))
  1308.                        (MAKE_CLOSURES-parms pvm-instr)))
  1309.  
  1310.             ((COND)
  1311.              (for-each scan-opnd (COND-opnds pvm-instr)))
  1312.  
  1313.             ((JUMP)
  1314.              (scan-opnd (JUMP-opnd pvm-instr)))
  1315.  
  1316.             (else
  1317.              '()))))
  1318.  
  1319.       (if (proc-obj-primitive? p)
  1320.         (display "**** #[primitive " port)
  1321.         (display "**** #[procedure " port))
  1322.       (display (proc-obj-name p) port)
  1323.       (display "] =" port)
  1324.       (newline port)
  1325.  
  1326.       (for-each scan-code (bbs->code-list (proc-obj-code p)))
  1327.  
  1328.       (newline port))
  1329.        
  1330.     (scan-opnd (make-obj proc))
  1331.  
  1332.     (let loop ()
  1333.       (if (not (queue-empty? proc-left))
  1334.         (begin
  1335.           (dump-proc (queue-get! proc-left))
  1336.           (loop))))))
  1337.  
  1338. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1339. ;
  1340. ; Virtual instruction writing:
  1341. ; ---------------------------
  1342.  
  1343. (define (write-pvm-instr pvm-instr port)
  1344.  
  1345.   (define (write-closure-parms parms)
  1346.     (let ((len (write-pvm-opnd (closure-parms-loc parms) port)))
  1347.       (display ",L" port)
  1348.       (let ((len (+ len (+ 2 (write-returning-len
  1349.                                (closure-parms-lbl parms)
  1350.                                port)))))
  1351.         (let loop ((l (closure-parms-opnds parms)) (len len))
  1352.           (if (pair? l)
  1353.             (let ((opnd (car l)))
  1354.               (display "," port)
  1355.               (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
  1356.             len)))))
  1357.  
  1358.   (define (write-upcase str)
  1359.     (let ((len (string-length str)))
  1360.       (let loop ((i 0))
  1361.         (if (< i len)
  1362.           (begin
  1363.             (write-char (char-upcase (string-ref str i)) port)
  1364.             (loop (+ i 1)))
  1365.           len))))
  1366.  
  1367.   (define (write-task-method method)
  1368.     (if method
  1369.       (begin
  1370.         (display "," port)
  1371.         (+ 1 (write-upcase (symbol->string method))))
  1372.       0))
  1373.  
  1374.   (define (write-instr pvm-instr)
  1375.     (case (pvm-instr-type pvm-instr)
  1376.  
  1377.       ((LABEL)
  1378.        (display "LABEL(L" port)
  1379.        (let ((len (+ 7 (write-returning-len (LABEL-lbl-num pvm-instr) port))))
  1380.          (case (LABEL-type pvm-instr)
  1381.            ((SIMP)
  1382.             (display ",SIMP)" port)
  1383.             (+ len 6))
  1384.            ((TASK)
  1385.             (display ",TASK" port)
  1386.             (let ((len (+ len
  1387.                           (+ 5
  1388.                              (write-task-method
  1389.                                (LABEL-TASK-method pvm-instr))))))
  1390.               (display ")" port)
  1391.               (+ len 1)))
  1392.            ((PROC)
  1393.             (display ",PROC," port)
  1394.             (let ((len (+ len
  1395.                           (+ 6
  1396.                              (if (not (= (LABEL-PROC-min pvm-instr)
  1397.                                          (LABEL-PROC-nb-parms pvm-instr)))
  1398.                                (let ((len (+ len
  1399.                                              (write-returning-len
  1400.                                                (LABEL-PROC-min pvm-instr)
  1401.                                                port))))
  1402.                                  (display "-" port)
  1403.                                  (+ len 1))
  1404.                                0)))))
  1405.               (let ((len (+ len
  1406.                             (write-returning-len
  1407.                               (LABEL-PROC-nb-parms pvm-instr)
  1408.                               port))))
  1409.                 (let ((len (+ len
  1410.                               (if (LABEL-PROC-rest? pvm-instr)
  1411.                                 (begin (display "..." port) 3)
  1412.                                 0))))
  1413.                   (let ((len (+ len
  1414.                                 (if (LABEL-PROC-closed? pvm-instr)
  1415.                                   (begin (display ",CLOSED" port) 7)
  1416.                                   0))))
  1417.                     (display ")" port)
  1418.                     (+ len 1))))))
  1419.            ((RETURN)
  1420.             (display ",RETURN" port)
  1421.             (let ((len (+ len
  1422.                           (+ 7
  1423.                              (write-task-method
  1424.                                (LABEL-RETURN-task-method pvm-instr))))))
  1425.               (display ")" port)
  1426.               (+ len 1)))
  1427.            (else
  1428.             (compiler-internal-error
  1429.               "write-pvm-instr, unknown label type")))))
  1430.  
  1431.       ((APPLY)
  1432.        (display "  APPLY(" port)
  1433.        (let ((len (+ 8 (display-returning-len
  1434.                          (proc-obj-name (APPLY-prim pvm-instr))
  1435.                          port))))
  1436.           (let loop ((l (APPLY-opnds pvm-instr)) (len len))
  1437.             (if (pair? l)
  1438.               (let ((opnd (car l)))
  1439.                 (display "," port)
  1440.                 (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
  1441.               (begin
  1442.                 (display "," port)
  1443.                 (let ((len (+ len
  1444.                               (+ 1
  1445.                                  (if (APPLY-loc pvm-instr)
  1446.                                    (write-pvm-opnd (APPLY-loc pvm-instr) port)
  1447.                                    0)))))
  1448.                   (display ")" port)
  1449.                   (+ len 1)))))))
  1450.  
  1451.       ((COPY)
  1452.        (display "  COPY(" port)
  1453.        (let ((len (+ 7 (write-pvm-opnd (COPY-opnd pvm-instr) port))))
  1454.          (display "," port)
  1455.          (let ((len (+ len (+ 1 (write-pvm-opnd (COPY-loc pvm-instr) port)))))
  1456.            (display ")" port)
  1457.            (+ len 1))))
  1458.  
  1459.       ((MAKE_CLOSURES)
  1460.        (display "  MAKE_CLOSURES(" port)
  1461.        (let ((len (+ 16 (write-closure-parms
  1462.                           (car (MAKE_CLOSURES-parms pvm-instr))))))
  1463.          (let loop ((l (cdr (MAKE_CLOSURES-parms pvm-instr))) (len len))
  1464.            (if (pair? l)
  1465.              (let ((x (car l)))
  1466.                (display "/" port)
  1467.                (loop (cdr l) (+ len (+ (write-closure-parms x) 1))))
  1468.              (begin
  1469.                (display ")" port)
  1470.                (+ len 1))))))
  1471.  
  1472.       ((COND)
  1473.        (display "  COND(" port)
  1474.        (let ((len (+ 7 (display-returning-len
  1475.                          (proc-obj-name (COND-test pvm-instr))
  1476.                          port))))
  1477.          (let loop ((l (COND-opnds pvm-instr)) (len len))
  1478.            (if (pair? l)
  1479.              (let ((opnd (car l)))
  1480.                (display "," port)
  1481.                (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
  1482.              (begin
  1483.                (display ",L" port)
  1484.                (let ((len (+ len (+ 2 (write-returning-len
  1485.                                         (COND-true pvm-instr)
  1486.                                         port)))))
  1487.                  (display ",L" port)
  1488.                  (let ((len (+ len (+ 2 (write-returning-len
  1489.                                           (COND-false pvm-instr)
  1490.                                           port)))))
  1491.                    (let ((len (+ len (if (COND-intr-check? pvm-instr)
  1492.                                        (begin (display ",INTR-CHECK" port) 11)
  1493.                                        0))))
  1494.                      (display ")" port)
  1495.                      (+ len 1)))))))))
  1496.  
  1497.       ((JUMP)
  1498.        (display "  JUMP(" port)
  1499.        (let ((len (+ 7 (write-pvm-opnd (JUMP-opnd pvm-instr) port))))
  1500.          (let ((len (+ len (if (JUMP-nb-args pvm-instr)
  1501.                              (begin
  1502.                                (display "," port)
  1503.                                (+ 1 (write-returning-len
  1504.                                       (JUMP-nb-args pvm-instr)
  1505.                                       port)))
  1506.                              0))))
  1507.            (let ((len (+ len (if (JUMP-intr-check? pvm-instr)
  1508.                                (begin (display ",INTR-CHECK" port) 11)
  1509.                                0))))
  1510.              (display ")" port)
  1511.              (+ len 1)))))
  1512.  
  1513.       (else
  1514.        (compiler-internal-error
  1515.          "write-pvm-instr, unknown 'pvm-instr':"
  1516.          pvm-instr))))
  1517.  
  1518.   (define (spaces n)
  1519.     (if (> n 0)
  1520.       (if (> n 7)
  1521.         (begin (display "        " port) (spaces (- n 8)))
  1522.         (begin (display " " port) (spaces (- n 1))))))
  1523.  
  1524.   (let ((len (write-instr pvm-instr)))
  1525.     (spaces (- 80 len))
  1526.     (display " " port)
  1527.     (write-frame (pvm-instr-frame pvm-instr) port))
  1528.  
  1529.   (let ((x (pvm-instr-comment pvm-instr)))
  1530.     (if x
  1531.       (let ((y (comment-get x 'TEXT)))
  1532.         (if y
  1533.           (begin
  1534.             (display " ; " port)
  1535.             (display y port)))))))
  1536.  
  1537. (define (write-frame frame port)
  1538.  
  1539.   (define (write-var var opnd sep)
  1540.     (display sep port)
  1541.     (write-pvm-opnd opnd port)
  1542.     (if var
  1543.       (begin
  1544.         (display "=" port)
  1545.         (cond ((eq? var closure-env-var)
  1546.                (write (map (lambda (var) (symbol->string (var-name var)))
  1547.                            (frame-closed frame))
  1548.                       port))
  1549.               ((eq? var ret-var)
  1550.                (display "RET" port))
  1551.               ((temp-var? var)
  1552.                (display "TMP" port))
  1553.               (else
  1554.                (write (symbol->string (var-name var)) port))))))
  1555.  
  1556.   (define (live? var)
  1557.     (let ((live (frame-live frame)))
  1558.       (or (set-member? var live)
  1559.           (and (eq? var closure-env-var)
  1560.                (not (set-empty? (set-intersection
  1561.                                   live
  1562.                                   (list->set (frame-closed frame)))))))))
  1563.  
  1564.   (display "{" port)
  1565.   (let loop1 ((i 1) (l (reverse (frame-slots frame))) (sep ""))
  1566.     (if (pair? l)
  1567.       (let ((var (car l)))
  1568.         (write-var (if (live? var) var #f) (make-stk i) sep)
  1569.         (loop1 (+ i 1) (cdr l) " "))
  1570.       (let loop2 ((i 0) (l (frame-regs frame)) (sep sep))
  1571.         (if (pair? l)
  1572.           (let ((var (car l)))
  1573.             (if (live? var)
  1574.               (begin
  1575.                 (write-var var (make-reg i) sep)
  1576.                 (loop2 (+ i 1) (cdr l) " "))
  1577.               (loop2 (+ i 1) (cdr l) sep)))
  1578.           (display "}" port))))))
  1579.  
  1580. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1581. ;
  1582. ; Operand writing:
  1583. ; ---------------
  1584.  
  1585. (define (write-pvm-opnd pvm-opnd port)
  1586.  
  1587.   (define (write-opnd)
  1588.     (cond ((reg? pvm-opnd)
  1589.            (display "r" port)
  1590.            (+ 1 (write-returning-len (reg-num pvm-opnd) port)))
  1591.           ((stk? pvm-opnd)
  1592.            (display "s" port)
  1593.            (+ 1 (write-returning-len (stk-num pvm-opnd) port)))
  1594.           ((glo? pvm-opnd)
  1595.            (write-returning-len (symbol->string (glo-name pvm-opnd)) port))
  1596.           ((clo? pvm-opnd)
  1597.            (let ((x (write-pvm-opnd (clo-base pvm-opnd) port)))
  1598.              (display ":" port)
  1599.              (+ (write-returning-len (clo-index pvm-opnd) port) (+ x 1))))
  1600.           ((lbl? pvm-opnd)
  1601.            (display "L" port)
  1602.            (+ (write-returning-len (lbl-num pvm-opnd) port) 1))
  1603.           ((obj? pvm-opnd)
  1604.            (display "'" port)
  1605.            (+ (write-pvm-opnd-value (obj-val pvm-opnd) port) 1))
  1606.           (else
  1607.            (compiler-internal-error
  1608.              "write-pvm-opnd, unknown 'pvm-opnd':"
  1609.              pvm-opnd))))
  1610.  
  1611.   (if (pot-fut? pvm-opnd)
  1612.     (begin
  1613.       (display "?" port)
  1614.       (+ (write-opnd) 1))
  1615.     (write-opnd)))
  1616.  
  1617. (define (write-pvm-opnd-value val port)
  1618.   (cond ((false-object? val)
  1619.          (display "#f" port)
  1620.          2)
  1621.         ((undef-object? val)
  1622.          (display "#[undefined]" port)
  1623.          12)
  1624.         ((proc-obj? val)
  1625.          (if (proc-obj-primitive? val)
  1626.            (display "#[primitive " port)
  1627.            (display "#[procedure " port))
  1628.          (let ((x (display-returning-len (proc-obj-name val) port)))
  1629.            (display "]" port)
  1630.            (+ x 13)))
  1631.         (else
  1632.          (write-returning-len val port))))
  1633.  
  1634. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1635.  
  1636. (define (virtual.begin!) ; initialize package
  1637.   (set! *opnd-table* (make-vector opnd-table-size))
  1638.   (set! *opnd-table-alloc* 0)
  1639.   '())
  1640.  
  1641. (define (virtual.end!) ; finalize package
  1642.   (set! *opnd-table* '())
  1643.   '())
  1644.  
  1645. ;==============================================================================
  1646.